home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE21 / TCP / SenderMain.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1997-02-05  |  6.0 KB  |  230 lines
  1. unit SenderMain;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   Buttons, OleCtrls, ISP, ExtCtrls, StdCtrls, Menus, ComCtrls, DB, DBTables;
  8.  
  9. type
  10.   TSendMain = class(TForm)
  11.     Panel1: TPanel;
  12.     Image1: TImage;
  13.     OpenDialog1: TOpenDialog;
  14.     MainMenu1: TMainMenu;
  15.     File1: TMenuItem;
  16.     Close1: TMenuItem;
  17.     Connection1: TMenuItem;
  18.     Connect1: TMenuItem;
  19.     Disconnect1: TMenuItem;
  20.     LoadnewBitmap1: TMenuItem;
  21.     StatusBar1: TStatusBar;
  22.     TCP1: TTCP;
  23.     Timer1: TTimer;
  24.     SendData1: TMenuItem;
  25.     SendBitMap1: TMenuItem;
  26.     Sendwav1: TMenuItem;
  27.     SendEXE1: TMenuItem;
  28.     procedure TCP1Error(Sender: TObject; Number: Smallint;
  29.       var Description: string; Scode: Integer; const Source,
  30.       HelpFile: string; HelpContext: Integer; var CancelDisplay: Wordbool);
  31.     procedure Connect1Click(Sender: TObject);
  32.     procedure Disconnect1Click(Sender: TObject);
  33.     procedure LoadnewBitmap1Click(Sender: TObject);
  34.     procedure Timer1Timer(Sender: TObject);
  35.     procedure Close1Click(Sender: TObject);
  36.     procedure TCP1Connect(Sender: TObject);
  37.     procedure Sendwav1Click(Sender: TObject);
  38.     procedure SendBitMap1Click(Sender: TObject);
  39.     procedure SendEXE1Click(Sender: TObject);
  40.   private
  41.     { Private declarations }
  42.   public
  43.     { Public declarations }
  44.   end;
  45.  
  46.  
  47. procedure SendTCPData(Location: Pointer; Size: Integer;
  48.      DataType : Integer; Tcp: TTcp);
  49.  
  50. var
  51.   SendMain: TSendMain;
  52.  
  53. implementation
  54. uses mmsystem, typInfo, oleauto, onei;
  55. {$R *.DFM}
  56.  
  57.  
  58. {This is the workhorse function, all transfering data comes
  59. through this function}
  60. procedure SendTCPData(Location: Pointer; Size: Integer; DataType :
  61.   Integer; Tcp: TTcp);
  62.  
  63. procedure FillHeader(PHeader: PTFisherTCP; DataType, Size : Integer);
  64. begin
  65.   PHeader^.Size := Size;
  66.   PHeader^.Tag := DataType;
  67. end;
  68.  
  69. var
  70.   PHeader: PTFisherTCP;
  71.   HeadBuffer, DataBuffer: Variant;
  72.   Ptr: Pointer;
  73. begin
  74.   PHeader := AllocMem(sizeOf(TFisherTCP));
  75.   try
  76.     FillHeader(PHeader, DataType, Size);
  77.     {send the header}
  78.     try
  79.       HeadBuffer := VarArrayCreate([0, SizeOf(TFisherTCP)-1], VarByte);
  80.       Ptr := VarArrayLock(HeadBuffer);
  81.       Move(PHeader^, Ptr^, SizeOf(TFisherTCP));
  82.     finally
  83.       VarArrayUnlock(HeadBuffer);
  84.     end;
  85.     Tcp.SendData(HeadBuffer);
  86.   finally
  87.     FreeMem(Pheader);
  88.   end;
  89.  
  90.   {Send the Stream}
  91.   DataBuffer := VarArrayCreate([0, Size -1] , VarByte);
  92.   try
  93.     Ptr := VarArrayLock(DataBuffer);
  94.     Move(Location^, Ptr^, Size);
  95.   finally
  96.     VarArrayUnlock(DataBuffer);
  97.   end;
  98.   Tcp.SendData(DataBuffer);
  99. end;
  100.  
  101. {--- There are 2 TCP event methods used----}
  102. procedure TSendMain.TCP1Error(Sender: TObject; Number: Smallint;
  103.   var Description: string; Scode: Integer; const Source, HelpFile: string;
  104.   HelpContext: Integer; var CancelDisplay: Wordbool);
  105. begin
  106.   Tcp1.Close;
  107.   ShowMessage(Description);
  108. end;
  109.  
  110. procedure TSendMain.TCP1Connect(Sender: TObject);
  111. begin
  112.   Disconnect1.Enabled := True;
  113.   Connect1.Enabled := False;
  114.   Connect1.Checked := True;
  115.   SendData1.Enabled := True;
  116. end;
  117.  
  118. {--------- Determine the state of the TCP control ------}
  119. {The timer calls GetTcpState() because this control does
  120.  not have an OnStateChange event - so we make our own}
  121. function GetTcpState(Tcp : TTcp): string;
  122. begin
  123.   case Tcp.State of
  124.    0 : Result := 'Closed';
  125.    1 : Result := 'Open';
  126.    2 : Result := 'Listening';
  127.    3 : Result := 'Connection is Pending';
  128.    4 : Result := 'Resolving the host name';
  129.    5 : Result := 'Host is Resolved';
  130.    6 : Result := 'Connecting';
  131.    7 : Result := 'Connected to ' + Tcp.RemoteHost;
  132.    8 : Result := 'Connection is closing';
  133.    9 : Result := 'State error has occurred';
  134.    10 : Result := 'Connection state is undetermined';
  135.   end;
  136. end;
  137.  
  138. procedure TSendMain.Timer1Timer(Sender: TObject);
  139. begin
  140.   StatusBar1.Panels[0].Text := GetTcpState(Tcp1);
  141.   StatusBar1.Panels[1].Text := 'Port ' + IntToStr(Tcp1.LocalPort);
  142. end;
  143.  
  144.  
  145. {--------- These are the functions that send the data ----------}
  146. procedure TSendMain.Sendwav1Click(Sender: TObject);
  147. var
  148.   DefaultFile : String;
  149.   Stream : TMemoryStream;
  150. begin
  151.   Stream := TmemoryStream.Create;
  152.   try
  153.     DefaultFile := ExtractFileDir(ParamStr(0)) + '\' + 'ah.wav';
  154.     Stream.LoadFromFile(DefaultFile);
  155.     Stream.Seek(0,0);
  156.     SendTCPData(Stream.Memory, Stream.Size, OneI_Wav, Tcp1);
  157.   finally
  158.     Stream.Free;
  159.   end;
  160. end;
  161.  
  162. procedure TSendMain.SendBitMap1Click(Sender: TObject);
  163. var
  164.   Stream : TMemoryStream;
  165. begin
  166.   Stream := TmemoryStream.Create;
  167.   try
  168.     SendMain.Image1.Picture.Bitmap.SaveToStream(Stream);
  169.     Stream.Seek(0,0);
  170.     SendTCPData(Stream.memory, Stream.Size, OneI_BitMap, Tcp1);
  171.   finally
  172.     Stream.Free;
  173.   end;
  174. end;
  175.  
  176. procedure TSendMain.SendEXE1Click(Sender: TObject);
  177. var
  178.   DefaultFile : String;
  179.   Stream : TMemoryStream;
  180. begin
  181.   Stream := TmemoryStream.Create;
  182.   try
  183.     DefaultFile := ExtractFileDir(paramstr(0)) + '\' + 'OneEye.exe';
  184.     Stream.loadFromFile(DefaultFile);
  185.     Stream.Seek(0,0);
  186.     SendTCPData(Stream.memory, Stream.size, 3, Tcp1);
  187.   finally
  188.     Stream.Free;
  189.   end;
  190. end;
  191.  
  192. {-------- Menu Item Click methods ----}
  193. procedure TSendMain.LoadnewBitmap1Click(Sender: TObject);
  194. begin
  195.   if OpenDialog1.execute then
  196.     Image1.Picture.Bitmap.LoadFromFile(OpenDialog1.FileName);
  197. end;
  198.  
  199. procedure TSendMain.Connect1Click(Sender: TObject);
  200. var
  201.   Server : String;
  202. begin
  203.   Server := '127.0.0.1';
  204.   if InputQuery('Computer to connect to', 'Address (either IP or Name):', Server) then
  205.    try
  206.      Tcp1.Connect(Server, 1024);
  207.    except
  208.      on E: EOleException do
  209.       ShowMessage('This ActiveX control can not reconnect to a server twice');
  210.    end;
  211. end;
  212.  
  213.  
  214.  
  215. procedure TSendMain.Disconnect1Click(Sender: TObject);
  216. begin
  217.   Tcp1.Close;
  218.   Senddata1.Enabled := False;
  219.   Connect1.Enabled := True;
  220.   Connect1.Checked := False;
  221.   Disconnect1.Enabled := False;
  222. end;
  223.  
  224. procedure TSendMain.Close1Click(Sender: TObject);
  225. begin
  226.   close;
  227. end;
  228.  
  229. end.
  230.